home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
MacTech 1 to 12
/
MacTech-vol-1-12.toast
/
Tools
/
Alpha 6.51b13 ƒ
/
Tcl
/
SystemCode
/
marks.tcl
< prev
next >
Wrap
Text File
|
1996-08-15
|
4KB
|
188 lines
# ================================================================================
# Clear marks for front window.
#================================================================================
proc gotoFileMark {} {
set text [getSelect]
if {[string length $text] && ([string length $text] < 20)} {
gotoMark [listpick -p "Mark?" -L [list $text] [getNamedMarks -n]]
} else {
gotoMark [listpick -p "Mark?" [getNamedMarks -n]]
}
}
proc markFile {} {
global mode
if {[llength [getNamedMarks -n]]} {
if {[askyesno -c "Clear old marks?"]} {
clearFileMarks
}
}
${mode}MarkFile
}
proc clearFileMarks {} {
set win [car [winNames -f]]
foreach mk [getNamedMarks -n] {
removeNamedMark -n $mk -w $win
}
}
proc sortMarksFile {} {
if {[askyesno "Really sort all marks?"] != "yes"} {return}
set nm [car [winNames -f]]
set mks {}
foreach mk [getNamedMarks] {
removeNamedMark -n [lindex $mk 0] -w [lindex $mk 1]
lappend mks $mk
}
foreach mk [lsort $mks] {
set name [lindex $mk 0]
set disp [lindex $mk 2]
set pos [lindex $mk 3]
set end [lindex $mk 4]
setNamedMark $name $disp $pos $end
}
}
# From Mark Nagata
proc zeroadd {num} {
set mx [maxPos]
set len [string length $mx]
set num [format "%0${len}d" $num]
return $num
}
proc orderMarks {} {
if {[askyesno "Really reorder all marks?"] != "yes"} {return}
set nm [car [winNames -f]]
set wks {}
foreach mk [getNamedMarks] {
removeNamedMark -n [lindex $mk 0] -w $nm
set name [lindex $mk 0]
set disp [lindex $mk 2]
set pos [lindex $mk 3]
set end [lindex $mk 4]
set pos [zeroadd $pos]
set wk [list $pos $disp $name $end]
lappend wks $wk
}
foreach wk [lsort $wks] {
set name [lindex $wk 2]
set disp [lindex $wk 1]
set pos [lindex $wk 0]
set end [lindex $wk 3]
setNamedMark $name $disp $pos $end
}
}
# ================================================================================
# Simple mark stack implementation
# ================================================================================
proc pushMark {} {
global markStack
global markName
set name mark$markName
incr markName
createTMark $name [getPos]
set fileName [car [winNames -f]]
set markStack [linsert $markStack 0 [list $fileName $name]]
message [concat Mark [llength $markStack] Pushed]
}
proc popMark {} {
global markStack
if {[llength $markStack] == "0"} {
message "The mark stack is empty!"
return
}
set mark [lindex [lindex $markStack 0] 1]
set markStack [lreplace $markStack 0 0]
if {[catch {gotoTMark $mark}]} {
popMark
return
}
message [concat Mark [expr [llength $markStack] + 1] Popped]
}
# Returns 'list' minus all top-level elements matching 'pat'.
# Used in 'closeHooks' to prune the mark stack.
proc removePat {list pat} {
while 1 {
set ind [lsearch $list $pat]
if {$ind == "-1"} {return $list}
set list [lreplace $list $ind $ind]
}
}
#================================================================================
# Only works while in same file.
#================================================================================
proc pointToRegister {} {
message "Letter?"
createTMark [set c [getChar]] [getPos]
message "Register '$c'"
}
proc jumpToRegister {} {
message "Letter?"
gotoTMark [set c [getChar]]
message "Register '$c'"
}
#================================================================================
proc fileMark {} {
set nm [car [winNames -f]]
global mks
set mks [getNamedMarks -n]
set res [statusPrompt "Goto mark: " markComp]
unset mks
if {[string length $res]} {
gotoMark $res
}
}
proc markComp {curr c} {
global mks
if {$c != "\t"} {return $c}
set matches {}
foreach w $mks {
if {[string match "$curr*" $w]} {
lappend matches $w
}
}
if {![llength $matches]} {
beep
} else {
return [string range [largestPrefix $matches] [string length $curr] end]
}
return ""
}